home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / cl-nd-cl.lha / clue / clio / utility.lisp < prev   
Lisp/Scheme  |  1990-07-19  |  8KB  |  202 lines
  1. ;;; -*- Mode:Lisp; Package:CLIO-OPEN; Base:10; Lowercase:T; Syntax:Common-Lisp -*-
  2.  
  3.  
  4. ;;;----------------------------------------------------------------------------------+
  5. ;;;                                                                                  |
  6. ;;;                          TEXAS INSTRUMENTS INCORPORATED                          |
  7. ;;;                                  P.O. BOX 149149                                 |
  8. ;;;                                AUSTIN, TEXAS 78714                               |
  9. ;;;                                                                                  |
  10. ;;;             Copyright (C) 1989, 1990 Texas Instruments Incorporated.             |
  11. ;;;                                                                                  |
  12. ;;; Permission is granted to any individual or institution to use, copy, modify, and |
  13. ;;; distribute this software, provided that  this complete copyright and  permission |
  14. ;;; notice is maintained, intact, in all copies and supporting documentation.        |
  15. ;;;                                                                                  |
  16. ;;; Texas Instruments Incorporated provides this software "as is" without express or |
  17. ;;; implied warranty.                                                                |
  18. ;;;                                                                                  |
  19. ;;;----------------------------------------------------------------------------------+
  20.  
  21.  
  22. (in-package "CLIO-OPEN")
  23.  
  24. (export '(
  25.       contact-current-background
  26.       contact-current-background-pixel
  27.  
  28.       inch-pixels
  29.       millimeter-pixels
  30.       pixel-inches
  31.       pixel-millimeters
  32.       pixel-points
  33.       point-pixels
  34.       ))
  35.  
  36. (defun contact-current-background (contact)
  37.   "Returns the current CONTACT background, searching upward through
  38.    the contact hierarchy to resolve :parent-relative."
  39.   (declare (values (or (member :none) pixel pixmap)))
  40.   (declare (type contact contact))
  41.   
  42.   (do ((contact contact (contact-ancestor contact))
  43.        (bg (contact-background contact) (contact-background contact)))
  44.       ((not (eq bg :parent-relative))
  45.        bg)))
  46.  
  47. (defmethod contact-ancestor ((contact contact))
  48.    (with-slots (parent) contact
  49.      parent))
  50.  
  51. (defmethod contact-ancestor ((shell shell))
  52.    (shell-owner shell))
  53.  
  54. (defun contact-current-background-pixel (contact &optional (default-pixel :white))
  55.   "Returns the current CONTACT background pixel, searching upward through
  56. the contact hierarchy to resolve :parent-relative.  If the search returns
  57. a non-pixel value, then the (converted) value of DEFAULT-PIXEL is returned."
  58.   (let ((bg (contact-current-background contact)))
  59.     (if (integerp bg) bg (convert contact default-pixel 'pixel))))
  60.     
  61.  
  62.  
  63. ;;;----------------------------------------------------------------------------+
  64. ;;;                                                                            |
  65. ;;;                  Unit Conversion                               |
  66. ;;;                                                                            |
  67. ;;;----------------------------------------------------------------------------+
  68.  
  69. (defconstant *points-per-mm* (/ 72.27 25.4)
  70.   "The number of points per millimeter.")
  71.  
  72. (defconstant *inches-per-mm* (/ 1.0 25.4)
  73.   "The number of inches per millimeter.")
  74.  
  75. (defun pixel-points (screen &optional (number 1) (dimension :vertical))
  76.   "Return the number of points represented by NUMBER pixels, in either
  77.    the :vertical or :horzontal DIMENSION of the SCREEN."
  78.   (declare (values number))
  79.   (declare (type screen screen)
  80.        (type number number)
  81.        (type (member :horizontal :vertical) dimension))
  82.   (* number (pixel-millimeters screen 1 dimension) *points-per-mm*))
  83.  
  84.  
  85. (defun point-pixels (screen &optional (number 1) (dimension :vertical))
  86.   "Return the number of pixels represented by NUMBER points, in either
  87.    the :vertical or :horzontal DIMENSION of the SCREEN."
  88.   (declare (values integer))
  89.   (declare (type screen screen)
  90.        (type number number)
  91.        (type (member :horizontal :vertical) dimension))
  92.   (round (/ number (pixel-millimeters screen 1 dimension) *points-per-mm*)))
  93.  
  94.  
  95. (defun pixel-inches (screen &optional (number 1) (dimension :vertical))
  96.   "Return the number of inches represented by NUMBER pixels, in either
  97.    the :vertical or :horzontal DIMENSION of the SCREEN."
  98.   (declare (values number))
  99.   (declare (type screen screen)
  100.        (type number number)
  101.        (type (member :horizontal :vertical) dimension))
  102.   (* number (pixel-millimeters screen 1 dimension) *inches-per-mm*))
  103.  
  104.  
  105. (defun inch-pixels (screen &optional (number 1) (dimension :vertical))
  106.   "Return the number of pixels represented by NUMBER inches, in either
  107.    the :vertical or :horzontal DIMENSION of the SCREEN."
  108.   (declare (values integer))
  109.   (declare (type screen screen)
  110.        (type number number)
  111.        (type (member :horizontal :vertical) dimension))
  112.   (round (/ number (pixel-millimeters screen 1 dimension) *inches-per-mm*)))
  113.  
  114. (defun pixel-millimeters (screen &optional (number 1) (dimension :vertical))
  115.   "Return the number of millimeters represented by NUMBER pixels, in either
  116.    the :vertical or :horzontal DIMENSION of the SCREEN."
  117.   (declare (values number))
  118.   (declare (type screen screen)
  119.        (type number number)
  120.        (type (member :horizontal :vertical) dimension))
  121.   (* number
  122.      (/ (ecase dimension
  123.       (:vertical   (screen-height-in-millimeters screen))
  124.       (:horizontal (screen-width-in-millimeters screen)))
  125.     (ecase dimension
  126.       (:vertical   (screen-height screen))
  127.       (:horizontal (screen-width screen))))))
  128.  
  129.  
  130. (defun millimeter-pixels (screen &optional (number 1) (dimension :vertical))
  131.   "Return the number of pixels represented by NUMBER millimeters, in either
  132.    the :vertical or :horzontal DIMENSION of the SCREEN."
  133.   (declare (values integer))
  134.   (declare (type screen screen)
  135.        (type number number)
  136.        (type (member :horizontal :vertical) dimension))
  137.   (round (/ number (pixel-millimeters screen 1 dimension))))
  138.  
  139.  
  140. ;;;----------------------------------------------------------------------------+
  141. ;;;                                                                            |
  142. ;;;                  Font Utilities                                |
  143. ;;;                                                                            |
  144. ;;;----------------------------------------------------------------------------+
  145.  
  146.  
  147.  
  148. (defmethod find-font (contact fontname)
  149.   "Return an open font for the CONTACT. The FONTNAME represents a R3 fontname string
  150.    specifying the requested font properties. Nil is returned if no such font can be
  151.    opened."
  152.   (declare (type stringable fontname)
  153.        (values (or null font)))
  154.  
  155.   ;; Default method does no font negotiation
  156.   (open-font (contact-display contact) fontname))
  157.  
  158.  
  159.  
  160.  
  161. ;;;----------------------------------------------------------------------------+
  162. ;;;                                                                            |
  163. ;;;                               Miscellaneous                                |
  164. ;;;                                                                            |
  165. ;;;----------------------------------------------------------------------------+
  166.  
  167. (defun area-overlaps-p (x1 y1 width1 height1 x2 y2 width2 height2)
  168.   "Returns nil if the given rectangular areas do not intersect. Otherwise,
  169.    the return values are the x, y, width, and height of the intersection area."
  170.   (let (right1 bottom1 right2 bottom2)
  171.     (when
  172.       (and (< x2 (setf right1 (+ x1 width1)))
  173.        (< y2 (setf bottom1 (+ y1 height1)))
  174.        (> (setf right2 (+ x2 width2)) x1)
  175.        (> (setf bottom2 (+ y2 height2)) y1))
  176.  
  177.       (let ((x (max x1 x2)) (y (max y1 y2)))
  178.     (values x y (- (min right1 right2) x) (- (min bottom1 bottom2) y))))))
  179.  
  180.  
  181. (defun stringable-keyword (stringable)
  182.   "Converts a stringable to a keyword symbol"
  183.   (intern (nsubstitute #\- #\space (string-upcase stringable)) "KEYWORD"))
  184.  
  185. (defun stringable-label (stringable)
  186.   "Convert a stringable into a string suitable for a label."
  187.   (nsubstitute
  188.     #\space #\-
  189.     (if (symbolp stringable)
  190.     ;; Capitalize upper-case symbol name
  191.     (string-capitalize (symbol-name stringable))
  192.     ;; Else assume string capitalization is already handled.
  193.     (copy-seq stringable))))
  194.  
  195.  
  196. (defmacro pixel-round (length &optional divisor)
  197.   `(floor (+ 1/2 ,(if divisor `(/ ,length ,divisor) length))))
  198.  
  199.  
  200.  
  201.  
  202.